home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Binaries / examples / asl / semant.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  2.0 KB  |  64 lines  |  [TEXT/ttxt]
  1. (* $Id: semant.ml,v 1.2 91/08/22 15:03:16 ddr Exp $ *)
  2.  
  3. #open "asl";;
  4. #open "parser";;
  5.  
  6. type semval = Numval of int
  7.             | Funval of (semval -> semval);;
  8. exception Illtyped;;
  9. exception SemantBug of string;;
  10. let init_semantics caml_fun =
  11.     Funval
  12.       (function Numval n ->
  13.          Funval(function Numval m -> Numval(caml_fun n m)
  14.                         | _ -> raise Illtyped)
  15.               | _ -> raise Illtyped);;
  16. let caml_function = function
  17.     "+" -> prefix +
  18.   | "-" -> prefix -
  19.   | "*" -> prefix *
  20.   | "/" -> prefix /
  21.   | "=" -> (fun n m -> if n=m then 1 else 0)
  22.   | s -> raise (SemantBug "Unknown primitive");;
  23. let init_sem =  map (fun x -> init_semantics(caml_function x))
  24.                     init_env;;
  25. let global_sem = ref init_sem;;
  26. let rec nth n = function
  27.      []  -> raise (Failure "nth")
  28.   | x::l -> if n=1 then x else nth (n-1) l;;
  29. let rec semant rho = sem
  30.     where rec sem = function
  31.       Const n -> Numval n
  32.     | Var(n) -> nth n rho
  33.     | Cond(e1,e2,e3) ->
  34.         (match sem e1 with Numval 0 -> sem e3
  35.                          | Numval n -> sem e2
  36.                          | _ -> raise Illtyped)
  37.     | Abs(_,e') -> Funval(fun x -> semant (x::rho) e')
  38.     | App(e1,e2) -> (match sem e1
  39.                       with Funval(f) -> f (sem e2)
  40.                          | _ -> raise Illtyped)
  41. ;;
  42.  
  43. let semant_asl = function Decl(s,e) ->
  44.   semant !global_sem e
  45. ;;
  46.  
  47. let print_semval = function
  48.   Numval n -> print_string "Numval "; print_int n
  49. | Funval f -> print_string "Funval <fun>"
  50. ;;
  51.  
  52. (*
  53. semantics (parse_top "f = \\x. + x 1;");;
  54. semantics (parse_top "i = \\x. x;");;
  55. semantics (parse_top "x = i (f 2);");;
  56. semantics (parse_top "y = (C x (\\x.x) 2) 0;");;
  57. semantics (parse_top "z = \\f.((\\x.f(\\y.(x x) y))(\\x.f(\\y.(x x) y)));");;
  58. semantics (parse_top "f = z(\\f.(\\n. C (= n 0) 1 (* n (f (- n 1)))));");;
  59. semantics (parse_top "x = f 8;");;
  60. semantics (parse_top
  61.   "b = z(\\b.(\\n. C (= n 1) 1 (C (= n 2) 1 (+ (b(- n 1)) (b(- n 2))))));");;
  62. semantics (parse_top "x = b 9;");;
  63. *)
  64.